home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / textManip.tcl < prev    next >
Encoding:
Text File  |  2000-10-30  |  12.3 KB  |  465 lines
  1. #  AlphaTcl - core Tcl engine
  2. #===========================================================================
  3. # Information about a selection or window.
  4. #===========================================================================
  5. proc wordCount {{text ""}} {
  6.     if {$text == ""} {
  7.     if {[set chars [string length [set text [getSelect]]]]} {
  8.         set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  9.         set text [getSelect]
  10.     } else {
  11.         set chars [maxPos]
  12.         set lines [lindex [posToRowCol $chars] 0]
  13.         set text [getText [minPos] [maxPos]]
  14.     }
  15.     }
  16.     regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " text
  17.     set words [llength $text]
  18.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  19. }
  20.  
  21.  
  22. # FILE: sortLines.tcl
  23. #
  24. # This version of sortLines has the option of ignoring blanks/whitespace (-b)
  25. # and case-insensitive sorting (-i), or reverse sorting, and removing duplicates
  26. # if desired [-d]
  27. #     sortLines [-b] [-i] [-r] [-d]
  28.  
  29. # COPYRIGHT:
  30. #
  31. #    Copyright © 1992,1993 by David C. Black All rights reserved.
  32. #    Portions copyright © 1990, 1991, 1992 Pete Keleher. All Rights Reserved.
  33. #   Portions copyright (c) 1999 Vince Darley, no rights reserved.
  34. #
  35. #    Redistribution and use in source and binary forms are permitted
  36. #    provided that the above copyright notice and this paragraph are
  37. #    duplicated in all such forms and that any documentation,
  38. #    advertising materials, and other materials related to such
  39. #    distribution and use acknowledge that the software was developed
  40. #    by David C. Black.
  41. #
  42. #    THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
  43. #    IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
  44. #    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  45. #
  46. ################################################################################
  47.  
  48. # AUTHOR
  49. #
  50. #    David C. Black
  51. #    GEnie:    D.C.Black
  52. #    Internet: black@mpd.tandem.com (preferred)
  53. #    USnail:   6217 John Chisum Lane, Austin, TX 78749
  54. #
  55. ################################################################################
  56.  
  57. proc reverseSort {} {sortLines -r}
  58.  
  59. proc sortLines {args} {
  60.     getOpts
  61.  
  62.     if {[info exists opts(-r)]} {
  63.     set mode "-decreas"
  64.     } else {
  65.     set mode "-increas"
  66.     }
  67.  
  68.     if {[pos::compare [getPos] == [selEnd]]} {
  69.     set start [minPos]
  70.     set end [maxPos]
  71.     } else {
  72.     # We extend last line to the end :
  73.     if {![is::Eol [lookAt [pos::math [selEnd] - 1]]]} {
  74.         set end [nextLineStart [selEnd]]
  75.     } else {
  76.         set end [selEnd]
  77.     }
  78.     # We extend first line to the start :
  79.     set start [lineStart [getPos]]
  80.     }
  81.     if {![is::Eol [lookAt [pos::math $end - 1]]]} {
  82.     set endoftext $end
  83.     } else {
  84.     set endoftext [pos::math $end - 1]
  85.     }
  86.     set text [split [getText $start $endoftext] "\n\r"]
  87.     if {[info exists opts(-b)] || [info exists opts(-i)] \
  88.       || [info exists opts(-d)]} {
  89.     foreach line $text {
  90.         if {[info exists opts(-i)]} {
  91.         set key [string tolower $line]
  92.         } else {
  93.         set key $line
  94.         }
  95.         if {[info exists opts(-b)]} {
  96.         regsub -all "\[ \t\]+" $key " " key
  97.         }
  98.         if {![info exists orig($key)]} {
  99.         set orig($key) $line
  100.         lappend list $key
  101.         } elseif {![info exists opts(-d)]} {
  102.         while {[info exists dup($key)]} {
  103.             append key "z"
  104.         }
  105.         set dup($key) $line
  106.         }
  107.     }
  108.     unset text
  109.     foreach key [lsort $mode $list] {
  110.         lappend text $orig($key)
  111.         while {[info exists dup($key)]} {
  112.         lappend text $dup($key)
  113.         append key "z"
  114.         }
  115.     }
  116.     } else {
  117.     set text [lsort $mode $text]
  118.     }
  119.     set text [join $text "\r"]
  120.     replaceText $start $endoftext $text
  121.     set endoftext [pos::math $start + [string length $text] + 1]
  122.     if {[pos::compare [maxPos] < $endoftext]} {
  123.     set endoftext [maxPos]
  124.     }
  125.     select $start $endoftext
  126. }
  127.  
  128. # Test case:
  129. #
  130. # a  black
  131. # A  black dog
  132. # a black cat
  133. # A  Black dog
  134. # A  black dog
  135.  
  136.  
  137. ## 
  138.  # -------------------------------------------------------------------------
  139.  # 
  140.  # "sortParagraphs" --
  141.  # 
  142.  #  Sorts selected paragraphs according to their first 30 characters,
  143.  #  it's case insensitive and removes all non alpha-numeric characters
  144.  #  before the sort.
  145.  # -------------------------------------------------------------------------
  146.  ##
  147. proc sortParagraphs {args} {
  148.     set start [getPos]
  149.     set end  [selEnd]
  150.     if {[pos::compare [getPos] == [selEnd]]} {
  151.     set start [minPos]
  152.     set end [maxPos]
  153.     } else {
  154.     # We extend last line to the end :
  155.     if {![is::Eol [lookAt [pos::math [selEnd] - 1]]]} {
  156.         set end [nextLineStart [selEnd]]
  157.     } else {
  158.         set end [selEnd]
  159.     }
  160.     # We extend first line to the start :
  161.     set start [lineStart [getPos]]
  162.     }
  163.     if {![is::Eol [lookAt [pos::math $end - 1]]]} {
  164.     set endoftext $end
  165.     } else {
  166.     set endoftext [pos::math $end - 1]
  167.     }
  168.     set text [getText $start $end]
  169.  
  170.     if {[string first "•" $text] != -1} {
  171.     alertnote "Sorry, can't sort paragraphs with bullets '•'."
  172.     return
  173.     }
  174.     regsub -all "\[\r\n\]\[ \t\]*\[\r\n]" $text "\r•" text
  175.     set paras [split $text "•"]
  176.     unset text
  177.     # now each paragraph ends in \r
  178.     foreach para $paras {
  179.     set key [string tolower [string range $para 0 30]]
  180.     regsub -all {[^-a-z0-9]} $key "" key
  181.     # so we don't clobber duplicates!
  182.     if {![info exists orig($key)]} {
  183.         set orig($key) $para
  184.     } else {
  185.         while {[info exists dup($key)]} {
  186.         append key "z"
  187.         }
  188.         set dup($key) $para
  189.     }
  190.     }
  191.     unset para
  192.     foreach key [lsort [array names orig]] {
  193.     lappend text $orig($key)
  194.     while {[info exists dup($key)]} {
  195.         lappend text $dup($key)
  196.         append key "z"
  197.     }
  198.     }
  199.     replaceText $start $end [join $text "\r"]
  200.     select $start $end
  201. }
  202.  
  203. #================================================================================
  204. # Block shift left and right.
  205. #================================================================================
  206.  
  207. proc shiftBy {amount} {
  208.     set start [lineStart [getPos]]
  209.     set end [nextLineStart [pos::math [selEnd] - 1]]
  210.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  211.     set text [text::indentBy [getText $start $end] $amount]
  212.     replaceText $start $end $text
  213.     set end [pos::math $start + [string length $text]]
  214.     if {[pos::compare [nextLineStart $start] == $end]} {
  215.     goto [pos::math $start + [string length $text] - [string length [string trimleft $text]]]
  216.     } else {
  217.     select $start $end
  218.     }
  219. }
  220.  
  221. proc shiftRight {} {
  222.     global indentationAmount
  223.     shiftBy $indentationAmount
  224. }
  225.  
  226. proc shiftLeft {} {
  227.     global indentationAmount
  228.     shiftBy -$indentationAmount
  229. }
  230.  
  231. proc shiftLeftSpace {} {
  232.     shiftBy -1
  233. }
  234.  
  235. proc shiftRightSpace {} {
  236.     shiftBy 1
  237. }
  238.  
  239. proc doShiftLeft {shiftChar} {
  240.     set start [lineStart [getPos]]
  241.     set end [nextLineStart [pos::math [selEnd] - 1]]
  242.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  243.     
  244.     set text [split [getText $start [pos::math $end - 1]] "\r\n"]
  245.     
  246.     set textout ""
  247.     
  248.     foreach line $text {
  249.     if {[regexp "($shiftChar)(.*)$" $line "" "" c]} {
  250.         lappend textout $c
  251.     } else {
  252.         lappend textout $line
  253.     }
  254.     }
  255.     
  256.     set text [join $textout "\r"]    
  257.     replaceText $start [pos::math $end - 1] $text
  258.     select $start [pos::math $start + [expr {1 + [string length $text]}]]
  259. }
  260.  
  261. proc doShiftRight {shiftChar} {
  262.     set start [lineStart [getPos]]
  263.     set end [nextLineStart [pos::math [selEnd] - 1]]
  264.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  265.     
  266.     set text [split [getText $start [pos::math $end - 1]] "\r\n"]
  267.     
  268.     set text "$shiftChar[join $text \r${shiftChar}]"
  269.     replaceText $start [pos::math $end - 1] $text
  270.     select $start [pos::math $start + [expr {1 + [string length $text]}]]
  271. }
  272.  
  273. proc selectAll {} {
  274.     select [minPos] [maxPos]
  275. }
  276.  
  277. # Select the next or current word. If word already selected, will go to next.
  278. proc hiliteWord {} {
  279.     if {[pos::compare [getPos] != [selEnd]]} forwardChar
  280.     forwardWord
  281.     set start [getPos]
  282.     backwardWord
  283.     select $start [getPos] 
  284. }
  285.  
  286. ## 
  287.  # -------------------------------------------------------------------------
  288.  # 
  289.  # "togglePrefix" --
  290.  # 
  291.  #  Useful for e.g. Tcl mode to add/remove a '$', TeX to add/remove 
  292.  #  a backslash, etc.  Only works for single character prefixes.
  293.  # -------------------------------------------------------------------------
  294.  ##
  295. proc togglePrefix {pref} {
  296.     set p [getPos]
  297.     backwardWord
  298.     if {[lookAt [getPos]] == $pref} {
  299.     deleteChar
  300.     goto [pos::math $p -1]
  301.     } else {
  302.     insertText $pref
  303.     goto [pos::math $p +1]
  304.     }
  305. }
  306.  
  307. proc twiddle {} {
  308.     set orSelStart [getPos]
  309.     set orPos [selEnd]
  310.     if {[pos::compare $orPos < [pos::math [minPos] + 2]]} return
  311.  
  312.     set pos $orPos
  313.     set one [lookAt [pos::math $pos -1]]
  314.     
  315.     if {[string first $one " \r\n\t"] > -1} {
  316.     set searchResult [search -s -n -f 0 -m 0 -i 1 -r 1 {[^ \r\n\t]} [pos::math $pos - 1]]
  317.     if {[llength $searchResult] != 0} then {
  318.         set pos [pos::math [lindex $searchResult 0] + 1]
  319.         set one [lookAt [pos::math $pos - 1]]
  320.     }
  321.     }
  322.     set two [lookAt [pos::math $pos - 2]]
  323.     if {[string first $two " \r\n\t"] > -1} {
  324.     message "transposeChars aborted. A space is involved"
  325.     select $orSelStart $orPos
  326.     return
  327.     }
  328.     replaceText [pos::math $pos -2] $pos "$one$two"
  329.     select $orSelStart $orPos
  330.     message "transposed chars: ‘$one$two’"
  331. }
  332.  
  333.  
  334. # transposeWords transpose correctly the two words before the cursor
  335. # taking into account any other chars in between.  We must be after a word, then
  336. # the proc will be reversible.  
  337.  
  338. proc twiddleWords {} {
  339.     set orSelStart [getPos]
  340.     set pos [selEnd]
  341.     if {[pos::compare $orSelStart != $pos]} {
  342.     goto $pos; # deselect
  343.     }
  344.     
  345.     backwardWord; backwardWord;
  346.     set start1 [getPos]
  347.     forwardWord;
  348.     set end1 [getPos]
  349.     forwardWord;
  350.     set end2 [getPos]
  351.     backwardWord;
  352.     set start2 [getPos]
  353.     
  354.     if {[pos::compare $end2 > $pos] || [pos::compare $start2 > $pos] \
  355.       || [pos::compare $end1 > $pos]} {
  356.     message "transposeWords error: two words must be before"
  357.     select $orSelStart $pos
  358.     return
  359.     }
  360.     if {[pos::compare $start1 != $start2]} {
  361.     set mid [getText $end1 $start2]
  362.     set one [getText $start2 $end2]
  363.     set two [getText $start1 $end1]
  364.     replaceText $start1 $end2 "$one$mid$two"
  365.     # the original selection could be shorter than the words interchanged
  366.     goto $pos
  367.     message "transposed words “$one” with “$two”"
  368.     }
  369. }
  370.  
  371.  
  372. proc insertPrefix {} {doPrefix insert}
  373. proc removePrefix {} {doPrefix remove}
  374. proc doPrefix {which} {
  375.     global prefixString
  376.     if {[pos::compare [set start [getPos]] == [set end [selEnd]]]} {
  377.     set end [nextLineStart $start]
  378.     }
  379.     set start [lineStart $start]
  380.     set text [getText $start $end]
  381.     replaceText $start $end [doPrefixText $which $prefixString $text]
  382.     goto $start
  383.     endOfLine
  384. }
  385.  
  386. proc quoteChar {} {
  387.     message "Literal keystroke to be inserted:"
  388.     insertText [getChar]
  389. }
  390.  
  391. proc setPrefix {} {
  392.     global prefixString
  393.     if {[catch {prompt "New Prefix String:" $prefixString} res] == 1} return
  394.     set prefixString $res
  395. }
  396.  
  397. proc setSuffix {} {
  398.     global suffixString
  399.     if {[catch {prompt "New Suffix String:" $suffixString} res] == 1} return
  400.     set suffixString $res
  401. }
  402.  
  403. proc insertSuffix {} {doSuffix insert}
  404. proc removeSuffix {} {doSuffix remove}
  405. proc doSuffix {which} {
  406.     global suffixString
  407.     set pts [getEndpts]
  408.     set start [lindex $pts 0]
  409.     set end [lindex $pts 1]
  410.     set start [lineStart $start]
  411.     set end [nextLineStart [pos::math $end - 1]]
  412.     set text [getText $start $end]
  413.     set text [doSuffixText $which $suffixString $text]
  414.     replaceText $start $end $text
  415.     select $start [getPos]
  416. }
  417.  
  418. proc prevLineStart { pos } {
  419.     return [lineStart [pos::math [lineStart $pos] - 1]]
  420. }
  421.  
  422.  
  423. proc frontTabsToSpaces { start end } {
  424.     select $start $end
  425.     tabsToSpaces
  426. }
  427.  
  428. proc frontSpacesToTabs { start end } {
  429.     getWinInfo a
  430.     set sp [string range "              " 1 $a(tabsize) ]
  431.     set from [lindex [posToRowCol $start] 0]
  432.     set to [lindex [posToRowCol $end] 0]
  433.     while {$from <= $to} {
  434.     set pos [rowColToPos $from 0]
  435.     # get the leading whitespace of the current line
  436.     set res [search -s -n -f 1 -r 1 "^\[ \t\]*" $pos]
  437.     if {![llength $res]} {
  438.         # end of the file
  439.         return
  440.     }
  441.     regsub -all "($sp| +\t)" [eval getText $res] "\t" front
  442.     eval replaceText $res [list $front]
  443.     incr from
  444.     }
  445. }
  446.  
  447. proc forwardDeleteUntil {{c ""}} {
  448.     if {$c == ""} {
  449.     message "Forward delete up to next:"
  450.     set c [getChar]
  451.     }
  452.     set p [lindex [search -s -n -f 1 -r 1 [quote::Regfind $c] [getPos]] 0]
  453.     if {$p != ""} {
  454.     deleteText [getPos] [pos::math $p + 1]
  455.     }
  456. }
  457.  
  458. proc forwardDeleteWhitespace {} {
  459.     set p [lindex [search -s -n -f 1 -r 1 "\[^ \t\r\n\]" [getPos]] 0]
  460.     if {$p != ""} {
  461.     deleteText [getPos] $p
  462.     }
  463. }
  464.  
  465.